perm filename TRONLY.OLD[NEW,LCS] blob
sn#265541 filedate 1977-12-14 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00002 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00002 00002 SUBROUTINE TRONLY
C00020 ENDMK
C⊗;
SUBROUTINE TRONLY
COMMON /PX/KPN(1) /Q/Q(1) /XRN/RN(1) /PTR/JST(1)
1 /RCLF/KK,CLEF,KW,KTEM,RSTAFF,SN,YN,RNAM,IRV,ITRANS
1 /IPG/IPG,JPG,XCLEF,RSTNUM(8),RPSZ(8),RHGT(8),RRCLEF(8)
1 /ITX/ITX(18)
EQUIVALENCE (ITEM,JST(18)),(ITOT,JST(19))
1000 FORMAT(' TYPE INPUT NAME.EXT ',$)
2200 FORMAT(A5,A1,A3)
2201 FORMAT(1XA5,'.',A3)
400 FORMAT(' OUTPUT NAME.EXT ',$)
6 FORMAT(' WRITE OVER ',A5,'.',A3,'? ',$)
8 FORMAT(A1)
304 FORMAT(' TRANSP.= '$)
306 FORMAT(I)
SIG=-99
XSIG=0
300 TYPE 1000
ACCEPT 2200,NM,XIN,XIN
NX=NM+256
2001 TYPE 304
ACCEPT 2101,ITRANS
IF(ITRANS.GT.-20)GO TO 1101
2101 FORMAT(A3)
C NEXT FOR LETTER NAMES
DO 3101 K=1,18
3101 IF(ITRANS.EQ.ITX(K))GO TO 4101
5101 TYPE 240
GO TO 2001
240 FORMAT(' THIS TRANSP NOT OFFERED')
1101 REREAD 306,ITRANS
IF(ITRANS.EQ.0)GO TO 300
ITRANS=10-ITRANS
IF(ITRANS.EQ.22)ITRANS=17
C FOR DOWN OCT.
IF(ITRANS.GT.0)GO TO 700
IF(ITRANS.EQ.-2)ITRANS=18
C -2 NOW = UP OCT.
GO TO 700
4101 ITRANS=K
700 TYPE 400
ACCEPT 2200,NOUT,K,XOUT
IF(NOUT.NE.' ')GO TO 5
NOUT='AAAAA'
XOUT='TST'
C DEFAULT NAMES
5 IF(EXT.EQ.' ')EXT='TST'
IF(LOOKX(NOUT,XOUT).GE.0)GO TO 11
TYPE 6,NOUT,XOUT
ACCEPT 8,K
IF(K.EQ.'N')GO TO 700
11 JOUT=NOUT+256
10 IF(LOOKX(NM,XIN))GO TO 9
NM=NX
NX=NX+256
C WILL READ UP TO 52 FILES.
NOUT=JOUT
JOUT=JOUT+256
IF(LOOKX(NM,XIN).GE.0)CALL EXIT
9 CALL GETEXT(NM,XIN)
CALL EXTIN(JST,128)
CALL EXTIN(KPN,ITEM)
CALL EXTIN(Q,ITOT)
TYPE 2201,NM,XIN
ITEM=ITEM-2
C NEXT SORTS INTO LEFT-TO-RIGHT
CC KL=1
JPG=ITEM-1
333 DO 33 K=1,JPG
IF(CODEN(KPN,K,Q,J).GT.6)GO TO 33
A=Q(J+3)
DO 33 J=K+1,JPG
IF(CODEN(KPN,J,Q,L).GT.6)GO TO 33
IF(A.LE.Q(L+3))GO TO 33
CALL EXCH(KPN(J),KPN(K))
CC KL=J-1
GO TO 333
33 CONTINUE
C NEXT FIND HOW MANY STAVES. KSIG?
RS=0
DO 32 K=1,ITEM
R=CODEN(KPN,K,Q,J)
IF(R.GT.2)GO TO 32
IF(Q(J+2).GT.RS)RS=Q(J+2)
32 IF(R.EQ.17)SIG=0
JPG=RS+1
JITEM=ITEM
IOCT=0
KW=0
C FOUND KSIG, SO DON'T DO THE REST
IF(XSIG.NE.0)GO TO 199
RT=0
GO TO(94,94,93,92,92, 91,91,90,90,90, 97,97,96,96,95,
1 102,99,98),ITRANS
C EEb,EE,F↓,F#↓,G, Ab,A,Bb,B,DMY, Db,D,Eb,E,F BBb, 8↓, 8↑
RETURN
102 RT=8
GO TO 41
95 RT=RT-1
96 RT=RT-1
97 RT=RT-1
GO TO 41
98 RT=7
GO TO 45
99 RT=-7
45 IOCT=-1
GO TO 199
94 RT=RT+1
93 RT=RT+1
92 RT=RT+1
91 RT=RT+1
90 RT=RT+1
41 NSIG=-1
IF(SIG.EQ.0)GO TO 699
TYPE 42
42 FORMAT(' ADD KEY SIG? -- ',$)
RSIG=-1
ACCEPT 8,XSIG
299 IF(XSIG.NE.'Y')GO TO 199
699 NSIG=0
RSIG=0
XSIG=99
C ***** NEXT FOR KEY SIG. ********
399 IADD=0
C ADD= ADD OR SUBTR. # OR b FROM KSIG.
GO TO (73,78,75,76,81, 72,79,74,77,399,
1 71,80,73,78,75, 74),ITRANS
C EEb,EE,F↓,F#↓,G, Ab,A,Bb,B,DMY, Db,D,Eb,E,F BBb, 8↓, 8↑
71 IADD=IADD+1
72 IADD=IADD+1
73 IADD=IADD+1
74 IADD=IADD+1
75 IADD=IADD+1
C 75=F, 81=G, 79=A, 73=E FLAT, 74=Bb, 80=D
GO TO 199
76 IADD=IADD-1
77 IADD=IADD-1
78 IADD=IADD-1
79 IADD=IADD-1
80 IADD=IADD-1
81 IADD=IADD-1
199 K=1
XCLEF=0
CLEF=-1
CC RSIG=0
SLUR=0
PRX=99
MS=1
SN=KW
599 X=CODEN(KPN,K,Q,J)
IF(X.NE.4)GO TO 2
BAR=-1
MS=1
GO TO 100
2 IF(Q(J+2).NE.SN)GO TO 100
CHECK FOR STAFF NUM.
IF(X.EQ.1)GO TO 1
20 IF(X.NE.17)GO TO 12
RSIG=-1
R=Q(J+5)
C KSIG NUM.
X=R+IADD
CHANGED TO X
IF(X.NE.0)GO TO 23
M=Q(J)+3
C THIS WILL DELETE KSIG
ITOT=ITOT-M
KL=ITOT-J
CALL RLOOP(Q(J),Q(J+M),KL)
DO 334 J=K,JITEM
334 KPN(J)=KPN(J+1)-M
JITEM=JITEM-1
K=K-1
GO TO 100
23 Q(J+5)=X
NSIG=0
12 IF(X.EQ.5)GO TO 120
IF(X.NE.3)GO TO 26
IF(Q(J+5).GT.3)GO TO 100
C SKIP NON-CLEFS
IF(CLEF.GE.0)GO TO 100
C FINDS ONLY 1 CLEF PER STAFF
XCLEF=Q(J+5)
IF(Q(J).LT.3)XCLEF=0
CLEF=0
GO TO 100
26 IF(X.NE.6)GO TO 100
120 IF(RT.NE.8)GO TO 121
IF(XCLEF.EQ.1)RT=-4
C WHAT ABOUT C CLEFS??
121 Q(J+4)=Q(J+4)+RT
Q(J+5)=Q(J+5)+RT
IF(X.EQ.5)SLUR=Q(J+6)
C SAVES RIGHT POS. OF SLUR
GO TO 100
C FOR BEAMS AND SLURS
1 R=Q(J+4)
XRT=RT
IF(IOCT)GO TO 4
C IOCT=-1 FOR OCT+ OR OCT-
RX=AMOD(R,100.0)
RZ=AMOD(RX,7.0)
C THE NOTE NUM
IF(RZ)RZ=RZ+7
C PUTS IT IN 0-6 RANGE FOR ACCI CHANGE SECTION.
R5=Q(J+5)
A=AMOD(R5,10.0)
C THE ACCI
RN(MS)=A
RN(MS+1)=RX
C SAVE FOR REPEATS
MS=MS+2
CHNAT=3
IF(MS.LT.4)GO TO 205
N=MS-3
200 IF(RX.NE.RN(N))GO TO 201
IF(A.EQ.0)GO TO 4
C NOW WE'VE FOUND THE SAME NOTE WITH NO ACCI IN SAME MEAS.
GO TO 203
201 N=N-2
IF(N.GE.1)GO TO 200
205 IF(NSIG)CHNAT=0
203 ADD=A
C THE CHANGE IN ACCI
IF(PRX.NE.RX)GO TO 44
C IF PREV ACCI AND NT ARE SAME, SKIP OVER.
IF(A.NE.0)GO TO 44
C NOW SAME NOTE, NO ACCI
IF(ABS(SLUR-Q(J+3)).GT.3)GO TO 44
C FOUND CONNECTING TIE
C OR SET MS BACK TO 200 WHEN TIE IS PRESENT. THIS WILL
CAUSE LATER SAME NOTE TO HAVE ACCI (I HOPE.)
IF(BAR)MS=1
IF(A.NE.0)GO TO 203
GO TO 4
44 IF(NSIG)GO TO 440
IF(ITRANS.GE.16)GO TO 69
IF(A.EQ.0)GO TO 4
C ONLY CHECKS ON NOTES WITH NO ACCI
440 IF(XCLEF.NE.1)GO TO 69
RZ=RZ-5
IF(RZ)RZ=RZ+7
69 GO TO (63,52,53,54,55, 56,57,58,59,440, 61,62,63,52,53
1 ,64),ITRANS
C EEb,EE,F↓,F#↓,G, Ab,A,Bb,B,DMY, Db,D,Eb,E,F BBb
54 IF(RZ.EQ.3)GO TO 101
59 IF(RZ.EQ.6)GO TO 101
52 IF(RZ.EQ.2)GO TO 101
57 IF(RZ.EQ.5)GO TO 101
C FOR "A". FINDS C,F AND G.
62 IF(RZ.EQ.1)GO TO 101
55 IF(RZ.EQ.4)GO TO 101
C "G" F→Bb, F#→B NAT.
GO TO 4
61 IF(RZ.EQ.5)GO TO 7
56 IF(RZ.EQ.2)GO TO 7
63 IF(RZ.EQ.6)GO TO 7
58 IF(RZ.EQ.3)GO TO 7
53 IF(RZ.NE.0)GO TO 4
7 IF(A.EQ.0)GO TO 402
IF(A.EQ.3)GO TO 402
C CHNG NO ACCI OR NAT TO SHARP
IF(A.EQ.4)GO TO 401
C 4=bb 5=##
IF(A.EQ.2)GO TO 405
30 ADD=CHNAT
C MAKE IT NAT. IF NEEDED
3 Q(J+5)=R5-A+ADD
4 PRX=RX
C REAL NOTE LEVEL
Q(J+4)=R+XRT
BAR=0
100 IF(K.GE.JITEM)GO TO 499
K=K+1
GO TO 599
C NEXT FOR BSCLAR.---ADD OTHERS HERE!!!
64 IF(XCLEF.EQ.1)XRT=XRT-12
GO TO 58
101 IF(A.EQ.0)GO TO 401
IF(A.EQ.2)GO TO 30
IF(A.EQ.3)GO TO 401
IF(A.EQ.5)GO TO 402
C WON'T HANDLE Gbb→Ab
404 ADD=4
GO TO 3
401 ADD=1
GO TO 3
402 ADD=2
GO TO 3
405 ADD=5
GO TO 3
499 KW=KW+1
IF(RSIG)GO TO 498
IF(IADD.EQ.0)GO TO 498
M=ITOT
C INSERT NEW KSIG
Q(M)=4
Q(M+1)=17
Q(M+2)=SN
Q(M+3)=9
Q(M+4)=0
Q(M+5)=IADD
Q(M+6)=XCLEF
ITOT=ITOT+7
JITEM=JITEM+1
KPN(JITEM+1)=ITOT
498 IF(KW.LT.JPG)GO TO 199
CALL RVRS(JITEM)
C TO REVERSE STEMS, BEAMS AND SLURS
497 DO 496 K=1,ITEM-1
C THIS REORDERS PTR ARRAY
IF(KPN(K).LT.KPN(K+1))GO TO 496
CALL EXCH(KPN(K),KPN(K+1))
GO TO 497
496 CONTINUE
CALL PUTEXT(NOUT,XOUT)
ITEM=JITEM+2
CALL EXTOUT(JST,128)
CALL EXTOUT(KPN,ITEM)
CALL EXTOUT(Q,ITOT)
CALL FINEXT
TYPE 2201,NOUT,XOUT
NOUT=NOUT+2
NM=NM+2
GO TO 10
END